home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / LISP / FOOLS / !Fl / scm / init < prev    next >
Text File  |  1991-10-16  |  8KB  |  245 lines
  1. ;;; fools' lisp init file
  2.  
  3. ; c[ad]+r
  4. (define caar (lambda (l) (car (car l))))
  5. (define cdar (lambda (l) (cdr (car l))))
  6. (define cadr (lambda (l) (car (cdr l))))
  7. (define cddr (lambda (l) (cdr (cdr l))))
  8. (define caaar (lambda (l) (car (car (car l)))))
  9. (define cdaar (lambda (l) (cdr (car (car l)))))
  10. (define cadar (lambda (l) (car (cdr (car l)))))
  11. (define cddar (lambda (l) (cdr (cdr (car l)))))
  12. (define caadr (lambda (l) (car (car (cdr l)))))
  13. (define cdadr (lambda (l) (cdr (car (cdr l)))))
  14. (define caddr (lambda (l) (car (cdr (cdr l)))))
  15. (define cdddr (lambda (l) (cdr (cdr (cdr l)))))
  16. (define caaaar (lambda (l) (car (car (car (car l))))))
  17. (define cdaaar (lambda (l) (cdr (car (car (car l))))))
  18. (define cadaar (lambda (l) (car (cdr (car (car l))))))
  19. (define cddaar (lambda (l) (cdr (cdr (car (car l))))))
  20. (define caadar (lambda (l) (car (car (cdr (car l))))))
  21. (define cdadar (lambda (l) (cdr (car (cdr (car l))))))
  22. (define caddar (lambda (l) (car (cdr (cdr (car l))))))
  23. (define cdddar (lambda (l) (cdr (cdr (cdr (car l))))))
  24. (define caaadr (lambda (l) (car (car (car (cdr l))))))
  25. (define cdaadr (lambda (l) (cdr (car (car (cdr l))))))
  26. (define cadadr (lambda (l) (car (cdr (car (cdr l))))))
  27. (define cddadr (lambda (l) (cdr (cdr (car (cdr l))))))
  28. (define caaddr (lambda (l) (car (car (cdr (cdr l))))))
  29. (define cdaddr (lambda (l) (cdr (car (cdr (cdr l))))))
  30. (define cadddr (lambda (l) (car (cdr (cdr (cdr l))))))
  31. (define cddddr (lambda (l) (cdr (cdr (cdr (cdr l))))))
  32.  
  33. (define-macro define
  34.   (lambda (sym . body)
  35.     (if (pair? sym)
  36.     `(define ,(car sym) (lambda ,(cdr sym) ,@body))
  37.     `(define ,sym ,@body))))
  38.  
  39. (define-macro define-macro
  40.   (lambda (macro . body)
  41.     (if (pair? macro)
  42.     `(define-macro ,(car macro) (lambda ,(cdr macro) ,@body))
  43.     `(define-macro ,macro ,@body))))
  44.  
  45. (define (call/cc proc) (call-with-current-continuation proc))
  46.  
  47. ;;; make procedures for built-in constructs
  48. (define call-with-current-continuation call/cc)
  49. (define (apply func args) (apply func args))
  50.  
  51. (define (reduce fnc lst init)
  52.   ; apply binary fnc to each element in lst
  53.   ; (reduce + '(1 2 3) 0) is equivalent to (+ (+ (+ 0 1) 2) 3)
  54.   (if (null? lst) init (reduce fnc (cdr lst) (fnc init (car lst)))))
  55.  
  56. (define reverse
  57.   ; reverse the top elements of a list (non-destructive)
  58.   ((lambda ()
  59.      (define (reverse-iter lst rev)
  60.        (if (null? lst) rev (reverse-iter (cdr lst) (cons (car lst) rev))))
  61.      (lambda (lst) (reverse-iter lst '())))))
  62.  
  63. (define (map fcn lst)
  64.   (define (map-iter lst out)
  65.     (if (null? lst)
  66.     out
  67.     (map-iter (cdr lst) (cons (fcn (car lst)) out))))
  68.   (reverse (map-iter lst '())))
  69.  
  70. (define (for-each fcn lst)
  71.   (if (null? lst) #t (begin (fcn (car lst)) (for-each fcn (cdr lst)))))
  72.  
  73. (define-macro (let bindings . body)
  74.   ; macro to unsugar (let ((binding val) ... ) expr ... )
  75.   `((lambda ,(map car bindings) ,@body) ,@(map cadr bindings)))
  76.  
  77. (define-macro letrec
  78.   ; macro to unsugar (letrec ((rec-def val) ... ) expr ... )
  79.   ((lambda ()
  80.      (define (letrec-defs def)
  81.        `(define  ,(car def) ,@(cdr def)))
  82.      (lambda (defs . exprs)
  83.        `((lambda () ,@(map letrec-defs defs) ,@exprs))))))
  84.  
  85. (define-macro (cond . clauses)
  86.   (if (null? clauses)
  87.       #f
  88.       (let ((test (caar clauses)) (exprs (cdar clauses)))
  89.     (if (null? exprs)
  90.         (if (eq? test 'else)
  91.         #t
  92.         `(or ,test (cond ,@(cdr clauses))))
  93.         (if (eq? test 'else)
  94.         `(begin ,@exprs)
  95.         (if (and (pair? exprs) (eq? (car exprs) '=>))
  96.             (let ((result (string->uninterned-symbol "result")))
  97.               `(let ((,result ,test))
  98.              (if ,result
  99.                  (,(cadr exprs) ,result)
  100.                  (cond ,@(cdr clauses)))))
  101.             `(if ,test
  102.              (begin ,@exprs)
  103.              (cond ,@(cdr clauses)))))))))
  104.  
  105. (define (atom? x) (not (pair? x)))
  106.  
  107. (define (1- x) (- x 1))
  108. (define (1+ x) (+ x 1))
  109. (define (negative? a) (< a 0))
  110. (define (positive? a) (> a 0))
  111. (define (zero? a) (= a 0))
  112. (define (even? x) (= x (* 2 (floor (/ x 2)))))
  113. (define (odd? x) (not (= x (* 2 (floor (/ x 2))))))
  114. (define (complex? x) #f)
  115. (define (rational? x) #f)
  116. (define real? number?)
  117. (define (sqrt x) (expt x 0.5))
  118. (define (square x) (* x x))
  119. (define (modulo x y)
  120.   (let ((r (remainder x y)))
  121.     (if (negative? y)
  122.     (if (negative? r) r (+ r y))
  123.     (if (negative? r) (+ r y) r))))
  124. (define gcd
  125.   (letrec ((gcd-pos
  126.         (lambda (u v)
  127.           (if (= v 0) u
  128.           (gcd-pos v (remainder u v))))))
  129.     (lambda args
  130.       (reduce gcd-pos (map abs args) 0))))
  131. (define lcm
  132.   (letrec ((lcm-2
  133.         (lambda (u v)
  134.           (number->integer (* (/ u (gcd u v)) v)))))
  135.     (lambda args (reduce lcm-2 (map abs args) 1))))
  136. (define (truncate x)
  137.   (if (negative? x) (ceil x) (floor x)))
  138.  
  139. (define (nth n l)
  140.   ; nth item in list or #f if l is too short
  141.   (and (pair? l) (if (<= n 0) (car l) (nth (- n 1) (cdr l)))))
  142.  
  143. (define length
  144.   (letrec ((length-iter
  145.         (lambda (lst len)
  146.           (if (null? lst) len (length-iter (cdr lst) (+ len 1))))))
  147.     (lambda (lst) (length-iter lst 0))))
  148.  
  149. ; t if l terminates with a nil in the last cdr (may not return)
  150. ;(define (list? l)
  151. ;  (if (pair? l) (list? (cdr l)) (null? l)))
  152.  
  153. ; returns #f if l is circular
  154. (define list?
  155.   (letrec ((list-iter?
  156.         (lambda (l)
  157.           (if (pair? l) (list-iter? (cdr l)) (null? l)))))
  158.     (lambda (l) (if (cycle? l) #f (list-iter? l)))))
  159.  
  160. (define (memq item lst)
  161.   (if (null? lst) #f (if (eq? item (car lst)) lst (memq item (cdr lst)))))
  162. (define (memv item lst)
  163.   (if (null? lst) #f (if (eqv? item (car lst)) lst (memv item (cdr lst)))))
  164. (define (member item lst)
  165.   (if (null? lst) () (if (equal? item (car lst)) lst (member item (cdr lst)))))
  166.  
  167. (define (assq item table)
  168.   (if (null? table) #f
  169.       (if (eq? item (caar table)) (car table) (assq item (cdr table)))))
  170. (define (assv item table)
  171.   (if (null? table) #f
  172.       (if (eqv? item (caar table)) (car table) (assv item (cdr table)))))
  173. (define (assoc item table)
  174.   (if (null? table) #f
  175.       (if (equal? item (caar table)) (car table) (assoc item (cdr table)))))
  176.  
  177. (define (filter pred lst)
  178.   ; return a list of the items in lst satisfying pred
  179.   (define (filter-iter lst res)
  180.     (cond ((null? lst) res)
  181.       ((pred (car lst)) (filter-iter (cdr lst) (cons (car lst) res)))
  182.       (else (filter-iter (cdr lst) res))))
  183.   (reverse (filter-iter lst '())))
  184.  
  185. (define (equal? a b)
  186.   ; #t if the elements of a and b are recursively equal?
  187.   (or (eqv? a b)
  188.       (and (pair? a) (pair? b)
  189.        (equal? (car a) (car b))
  190.        (equal? (cdr a) (cdr b)))
  191.       (and (vector? a) (vector? b)
  192.        (equal? (vector->list a) (vector->list b)))
  193.       (and (box? a) (box? b)
  194.        (equal? (unbox a) (unbox b)))))
  195.  
  196. (define min
  197.   ; return the minimum of a list of numbers
  198.   (letrec ((min2 (lambda (a b) (if (< a b) a b))))
  199.     (lambda (first . rest) (reduce min2 rest first))))
  200.  
  201. (define max
  202.   ; return the maximum of a list of numbers
  203.   (letrec ((max2 (lambda (a b) (if (> a b) a b))))
  204.     (lambda (first . rest) (reduce max2 rest first))))
  205.  
  206. (define (newline . file)
  207.   (write-char #\newline (if (null? file) *stdout* (car file))))
  208.  
  209. (define string=? eqv?)
  210. (define char=? =)
  211. (define char<? <)
  212. (define char>? >)
  213. (define char<=? <=)
  214. (define char>=? >=)
  215.  
  216. ;;; ports
  217. ;;; note:  input and output ports are not separate types
  218. (define (open-input-file file) (file-open file "r"))
  219. (define (open-output-file file) (file-open file "w"))
  220. (define close-input-port file-close)
  221. (define close-output-port file-close)
  222. (define (current-input-port) *stdin*)
  223. (define (current-output-port) *stdout*)
  224. (define (input-port? file) (eq? (object-type file) 'file))
  225. (define output-port? input-port?)
  226. (define (call-with-input-file filename proc)
  227.   (let ((file (open-input-file filename)))
  228.     (begin1 (proc file) (close-input-port file))))
  229. (define (call-with-output-file filename proc)
  230.   (let ((file (open-output-file filename)))
  231.     (begin1 (proc file) (close-output-port file))))
  232. (define (peek-char port)
  233.   (let ((char (read-char port)))
  234.     (if (not (eof-object? char))
  235.     ; unread only if not EOF
  236.     (unread-char char port))
  237.     char))
  238.  
  239. ;;; tracing functions
  240. ;;; note:  tail recursive calls do not have traceable exits
  241. (define (trace proc) (trace-entry (trace-exit proc)))
  242. (define (untrace proc) (untrace-entry (untrace-exit proc)))
  243. (define (trace-all . procs) (for-each trace procs))
  244. (define (untrace-all . procs) (for-each untrace procs))
  245.